home *** CD-ROM | disk | FTP | other *** search
/ Aminet 31 / Aminet 31 (1999)(Schatztruhe)[!][Jun 1999].iso / Aminet / dev / lang / scm.lha / scm / Transcen.scm < prev   
Text File  |  1999-04-04  |  5KB  |  134 lines
  1. ;; Copyright (C) 1992, 1993, 1995, 1997 Free Software Foundation, Inc.
  2. ;;
  3. ;; This program is free software; you can redistribute it and/or modify
  4. ;; it under the terms of the GNU General Public License as published by
  5. ;; the Free Software Foundation; either version 2, or (at your option)
  6. ;; any later version.
  7. ;;
  8. ;; This program is distributed in the hope that it will be useful,
  9. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;; GNU General Public License for more details.
  12. ;;
  13. ;; You should have received a copy of the GNU General Public License
  14. ;; along with this software; see the file COPYING.  If not, write to
  15. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ;;
  17. ;; As a special exception, the Free Software Foundation gives permission
  18. ;; for additional uses of the text contained in its release of GUILE.
  19. ;;
  20. ;; The exception is that, if you link the GUILE library with other files
  21. ;; to produce an executable, this does not by itself cause the
  22. ;; resulting executable to be covered by the GNU General Public License.
  23. ;; Your use of that executable is in no way restricted on account of
  24. ;; linking the GUILE library code into it.
  25. ;;
  26. ;; This exception does not however invalidate any other reasons why
  27. ;; the executable file might be covered by the GNU General Public License.
  28. ;;
  29. ;; This exception applies only to the code released by the
  30. ;; Free Software Foundation under the name GUILE.  If you copy
  31. ;; code from other Free Software Foundation releases into a copy of
  32. ;; GUILE, as the General Public License permits, the exception does
  33. ;; not apply to the code that you add in this way.  To avoid misleading
  34. ;; anyone as to the status of such modified files, you must delete
  35. ;; this exception notice from them.
  36. ;;
  37. ;; If you write modifications of your own for GUILE, it is your choice
  38. ;; whether to permit this exception to apply to your modifications.
  39. ;; If you do not wish that, delete this exception notice.
  40.  
  41. ;;;; "Transcen.scm", Complex trancendental functions for SCM.
  42. ;;; Author: Jerry D. Hedden.
  43.  
  44. (define compile-allnumbers #t)        ;for HOBBIT compiler
  45.  
  46. (define (exp z)
  47.   (if (real? z) ($exp z)
  48.       (make-polar ($exp (real-part z)) (imag-part z))))
  49.  
  50. (define (log z)
  51.   (if (and (real? z) (>= z 0))
  52.       ($log z)
  53.       (make-rectangular ($log (magnitude z)) (angle z))))
  54.  
  55. (define (sqrt z)
  56.   (if (real? z)
  57.       (if (negative? z) (make-rectangular 0 ($sqrt (- z)))
  58.       ($sqrt z))
  59.       (make-polar ($sqrt (magnitude z)) (/ (angle z) 2))))
  60.  
  61. (define expt
  62.   (let ((integer-expt integer-expt))
  63.     (lambda (z1 z2)
  64.       (cond ((exact? z2)
  65.          (integer-expt z1 z2))
  66.         ((and (real? z2) (real? z1) (>= z1 0))
  67.          ($expt z1 z2))
  68.         (else
  69.          (exp (* z2 (log z1))))))))
  70.  
  71. (define (sinh z)
  72.   (if (real? z) ($sinh z)
  73.       (let ((x (real-part z)) (y (imag-part z)))
  74.     (make-rectangular (* ($sinh x) ($cos y))
  75.               (* ($cosh x) ($sin y))))))
  76. (define (cosh z)
  77.   (if (real? z) ($cosh z)
  78.       (let ((x (real-part z)) (y (imag-part z)))
  79.     (make-rectangular (* ($cosh x) ($cos y))
  80.               (* ($sinh x) ($sin y))))))
  81. (define (tanh z)
  82.   (if (real? z) ($tanh z)
  83.       (let* ((x (* 2 (real-part z)))
  84.          (y (* 2 (imag-part z)))
  85.          (w (+ ($cosh x) ($cos y))))
  86.     (make-rectangular (/ ($sinh x) w) (/ ($sin y) w)))))
  87.  
  88. (define (asinh z)
  89.   (if (real? z) ($asinh z)
  90.       (log (+ z (sqrt (+ (* z z) 1))))))
  91.  
  92. (define (acosh z)
  93.   (if (and (real? z) (>= z 1))
  94.       ($acosh z)
  95.       (log (+ z (sqrt (- (* z z) 1))))))
  96.  
  97. (define (atanh z)
  98.   (if (and (real? z) (> z -1) (< z 1))
  99.       ($atanh z)
  100.       (/ (log (/ (+ 1 z) (- 1 z))) 2)))
  101.  
  102. (define (sin z)
  103.   (if (real? z) ($sin z)
  104.       (let ((x (real-part z)) (y (imag-part z)))
  105.     (make-rectangular (* ($sin x) ($cosh y))
  106.               (* ($cos x) ($sinh y))))))
  107. (define (cos z)
  108.   (if (real? z) ($cos z)
  109.       (let ((x (real-part z)) (y (imag-part z)))
  110.     (make-rectangular (* ($cos x) ($cosh y))
  111.               (- (* ($sin x) ($sinh y)))))))
  112. (define (tan z)
  113.   (if (real? z) ($tan z)
  114.       (let* ((x (* 2 (real-part z)))
  115.          (y (* 2 (imag-part z)))
  116.          (w (+ ($cos x) ($cosh y))))
  117.     (make-rectangular (/ ($sin x) w) (/ ($sinh y) w)))))
  118.  
  119. (define (asin z)
  120.   (if (and (real? z) (>= z -1) (<= z 1))
  121.       ($asin z)
  122.       (* -i (asinh (* +i z)))))
  123.  
  124. (define (acos z)
  125.   (if (and (real? z) (>= z -1) (<= z 1))
  126.       ($acos z)
  127.       (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
  128.  
  129. (define (atan z . y)
  130.   (if (null? y)
  131.       (if (real? z) ($atan z)
  132.       (/ (log (/ (- +i z) (+ +i z))) +2i))
  133.       ($atan2 z (car y))))
  134.